home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / button.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  13.2 KB  |  547 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # file for button bindings (This is being re-written as we speak!
  8.  
  9. #    <prefix>_down:         The button went down
  10. #    <prefix>_start_sweep    We started a sweep
  11. #    <prefix>_sweep            We are sweeping
  12. #     <prefix>_end_sweep        We ended the sweep (button up)
  13. #     <prefix>_up            button up - no sweep
  14.  
  15. # arguments:
  16. #   win:        The window the button was clicked on (%W)
  17. #   x,y:        The absolute mouse coordinates (%X %Y)
  18.  
  19. ########################################################
  20. # procedures for managing hits on widget palette
  21.  
  22. proc palette_down {win x y} {
  23.     global _Message
  24.     set _Message "Drag to create a new [$win cget -text]"
  25.     $win configure -relief sunken
  26.     unselect_widget
  27. }
  28.  
  29. # To autoscroll a canvas, we schedule scrolling using after.
  30. # Cancel contains the next scheduled auto-scroll command.
  31. # to stop auto scrolling, cancel "Cancel"
  32.  
  33. set Cancel 0
  34. proc palette_start_sweep {win x y} {
  35.     global Type In_view Where Row Col
  36.     set Where ""
  37.     set Type [$win cget -text]
  38.     set In_view 0
  39.     set Row ""; set Col ""
  40.     unselect_widget
  41.     current_frame .can.f
  42.     label .label -bd 2 -relief ridge -text $Type
  43. }
  44.  
  45. # track the cursor over the canvas, keep track of its position
  46. # The optional "repeat" argument is used for auto-scrolling
  47.  
  48. set Status ""    ;# keep track of the row/col we're sitting on
  49. proc palette_sweep {win x y {repeat 0}} {
  50.     global P Current Frames Where Before
  51.     global Root_x Root_y Cancel Row Col
  52.     global _Message
  53.     global Status
  54.  
  55.     # make sure the widget is in view
  56.  
  57.     if {$repeat == 0} {
  58.         after cancel $Cancel
  59.     }
  60.     if {[keep_in_view .can $x $y]} {
  61.         place .label -anchor c -x [expr $x - $Root_x] -y [expr $y - $Root_y]
  62.     } else {
  63.         set Cancel [after $P(scroll_delay) "palette_sweep $win $x $y 1"]
  64.     }
  65.  
  66.     # where on the canvas are we?
  67.  
  68.     set Before $Where
  69.     set row $Row; set col $Col
  70.     set Where [find_slot $Current(frame) $x $y Row Col]
  71.     if {$Where == $Before && $Row == $row && $Col == $col} {
  72.         return
  73.     }
  74.     choose_look $win $Where
  75.  
  76.     switch  -glob $Where {
  77.         Cr    {                            # on a row grid line
  78.             arrow_unhighlight row
  79.         }
  80.         Cc    {                            # on a column grid line
  81.             arrow_unhighlight column
  82.         }
  83.         Crc    {                            # on both row and column grid line
  84.             arrow_unhighlight column
  85.             arrow_unhighlight row
  86.         }
  87.         C* {                            # in a slot
  88.             set on [blt_table slaves $Current(frame) -row $Row -column $Col]
  89.             if {$on != ""} {
  90.                 choose_look $win occupied
  91.                 if {[info exists Frames($on)]} {
  92.                     dputs "Entering sub-frame $on"
  93.                     current_frame [find_grid $x $y "" $on]
  94.                 }
  95.                 set Status "Occupied"
  96.                 set color red
  97.             } else {
  98.                 set Status ""
  99.                 set color green
  100.             }
  101.             arrow_highlight column $Current(frame) $Col $color
  102.             arrow_highlight row $Current(frame) $Row $color
  103.             set _Message "row: [expr $Row/2]    col: [expr $Col/2]    $Status"
  104.         }
  105.         default {                # outside the grid
  106.             dputs left frame $Current(frame)
  107.             current_frame [find_grid $x $y]
  108.         }
  109.     }
  110. }
  111.  
  112. # Create a new widget and plunk it down
  113.  
  114. proc palette_end_sweep {win x y} {
  115.     global Next_widget Type
  116.     global Current
  117.     global Cancel _Message
  118.     global Row Col Widgets
  119.     global Widget_data
  120.     global In_view Where
  121.     upvar #0 geom:$Current(frame) data
  122.  
  123.     # create the widget
  124.  
  125.     choose_look $win reset
  126.     destroy .label
  127.     if {$In_view == 0} {
  128.         return
  129.     }
  130.     check_table $Current(frame) $Where Row Col
  131.     set on [blt_table slaves $Current(frame) -row $Row -column $Col]
  132.     if {$on != ""} {
  133.         set _Message "$Row,$Col is occupied, [choose_insult]!"
  134.     } else {
  135.         undo_mark
  136.         set template .sample_$Type
  137.         set new .can.f.$Type#[incr Next_widget($Type)]
  138.         clone_widget $template $new
  139.         if {$Type == "frame"} {
  140.             bindtags $new "First frame widget [bindtags $new]"
  141.         } else {
  142.             bindtags $new "First widget [bindtags $new]"
  143.         }
  144.         set_master $new $Current(frame)
  145.         table_enter $Current(frame) $new $Row $Col
  146.  
  147.         widget_extract $new
  148.         set _Message "Created new $Type at $Row,$Col"
  149.         set name [winfo name $new]
  150.         set Widgets($name) 1
  151.         undo_log create_widget $name
  152.  
  153.         # Each widget class (potentially) has its own special case
  154.         # code to configure the class.  Run it here, as a filter
  155.  
  156.         if {[info exists Widget_data(filter:[winfo class $new])]} {
  157.             eval $Widget_data(filter:[winfo class $new]) $new
  158.         }
  159.  
  160.         outline_create $name
  161.         unselect_widget
  162.         select_widget $new
  163.  
  164.         # testing
  165.  
  166.         if {$Type == "frame"} {
  167.             dputs "Inserting subgrid tag for $new"
  168.             insert_tag $new sub_grid
  169.         }
  170.     }
  171.  
  172.     # destroy the temporary one
  173.  
  174.     arrow_unhighlight row
  175.     arrow_unhighlight column
  176.     after cancel $Cancel
  177.     set Type ""
  178. }
  179.  
  180. set Current(sample) ""    ;# this should be elsewhere
  181. proc palette_up {win x y} {
  182.     return        ;# use double click only!
  183. }
  184.  
  185. #######  AUX procedures used by bindings
  186.  
  187. # scroll canvas to keep in view
  188. # x and y are root coords
  189. # Make sure we don't scroll before the widget is in bounds
  190.  
  191. proc keep_in_view {win x y} {
  192.     global In_view
  193.     set in_bounds 0
  194.     if {$x < [winfo rootx $win]} {
  195.         if {$In_view} {
  196.             $win xview scroll -1 units
  197.             ${win}_column xview scroll -1 units
  198.         }
  199.     } elseif {$y < [winfo rooty $win]} {
  200.         $win yview scroll -1 units
  201.         ${win}_row yview scroll -1 units
  202.     } elseif {$x > [winfo rootx $win] + [winfo width $win]} {
  203.         $win xview scroll 1 units
  204.         ${win}_column xview scroll 1 units
  205.     } elseif {$y > [winfo rooty $win] + [winfo height $win]} {
  206.         $win yview scroll 1 units
  207.         ${win}_row yview scroll 1 units
  208.     } else {
  209.         set In_view 1
  210.         set in_bounds 1
  211.     }
  212.     if {$In_view && !$in_bounds} {
  213.         return 0
  214.     } else {
  215.         return 1
  216.     }
  217. }
  218.  
  219. # get the row and column position
  220. # win: table master
  221. # x,y: Root x and y coords
  222. # row,col: get filled in if True
  223. # result: code indicating where it is
  224. #  position relative to grid:  nw n ne e se s sw w
  225. #  where in grid: r c rc (row, column, row&column)
  226. #  "" on a grid slot
  227.  
  228. proc find_slot {win x y set_row set_col} {
  229.     upvar $set_row row $set_col col
  230.     set result ""
  231.     incr x -[winfo rootx $win.@0]
  232.     incr y -[winfo rooty $win.@0]
  233.     set row [blt_table row $win location $y]
  234.     set col [blt_table column $win location $x]
  235.  
  236.     if {$y < 0} {
  237.         append result n
  238.     } elseif {$row >= [blt_table row $win dimension]} {
  239.         append result s
  240.     }
  241.     if {$x < 0} {
  242.         append result w
  243.     } elseif {$col >= [blt_table column $win dimension]} {
  244.         append result e
  245.     }
  246.  
  247.     if {$result != ""} {
  248.         dputs $win $x,$y $row,$col $result
  249.         return $result
  250.     }
  251.     set result C
  252.  
  253.     if {$row&1} {
  254.         append result r
  255.     }
  256.     if {$col&1} {
  257.         append result c
  258.     }
  259.     dputs $win $x,$y $row,$col $result
  260.     return $result
  261. }
  262.  
  263. ########################################################3
  264. # procedures for managing hits on widgets
  265. # these should be combined with the palette routines!!
  266.  
  267. proc widget_down {win x y} {
  268.     global _Message Current
  269.     if {$win == $Current(widget)} {
  270.         set _Message "Double click to activate option sheet"
  271.     } else {
  272.         set _Message "selecting [winfo name $win]"
  273.     }
  274. }
  275.  
  276. # take 2 - sweep a label, not the entire widget
  277.  
  278. proc widget_start_sweep {win x y} {
  279.     global In_view Where Row Col
  280.     upvar #0 [winfo name $win] data
  281.     set Where ""
  282.     set In_view 0
  283.     set Row $data(row)
  284.     set Col $data(column)
  285.     unselect_widget
  286.     current_frame .can.f[find_master $win]
  287.     label .label -bd 2 -relief raised -text [widget_describe $win]
  288. }
  289.  
  290. proc widget_sweep {win x y {repeat 0}} {
  291.     palette_sweep $win $x $y $repeat
  292. }
  293.  
  294. proc widget_end_sweep {win x y} {
  295.     global Shift Cancel _Message Current
  296.     global Row Col Where
  297.     upvar #0 geom:$Current(frame) data
  298.     after cancel $Cancel
  299.  
  300.     # move or copy it!
  301.  
  302.     destroy .label
  303.     choose_look $win reset
  304.     check_table $Current(frame) $Where Row Col
  305.     unselect_widget
  306.     set on [blt_table slaves $Current(frame) -row $Row -column $Col]
  307.     if {$on == ""}  {
  308.         if {$Shift} {
  309.             undo_mark
  310.             set win [copy_widget $Current(frame) $win $Row,$Col]
  311.         } else {
  312.             move_widget $Current(frame) $win $Row $Col
  313.         }
  314.         set_master $win $Current(frame)
  315.         select_widget $win
  316.  
  317.         # Its confusing without this
  318.         blt_table configure $win -rowspan 1 -columnspan 1
  319.         set rowspan 1; set columnspan 1; set row $Row; set column $Col
  320.  
  321.         foreach i {row column columnspan rowspan} {
  322.             sync_form $i [set $i]
  323.         }
  324.     }
  325.     arrow_unhighlight row
  326.     arrow_unhighlight column
  327. }
  328.  
  329. # copy a widget to row,col
  330. # return widget name.  Assumes new widget is a sibling of the old one
  331. #  master:  The frame to manage the copy in
  332. #  win:        The widget to copy
  333. #  position:  row,col:        Where to put it (if moved)
  334.  
  335. # BROKEN for copying frames!
  336.  
  337. proc copy_widget {master win {position ""}} {
  338.     global Next_widget Widgets Frames P
  339.     dputs $master $win $position
  340.  
  341.     # name and clone the widget parameters
  342.  
  343.     set class [winfo class $win]
  344.     set type [string tolower $class]
  345.     set name $type#[incr Next_widget($type)]
  346.     set path .can.f.$name
  347.     clone_widget $win $path
  348.     upvar #0 $name dst [winfo name $win] src
  349.     array set dst [array get src]
  350.  
  351.     # change the parameters
  352.  
  353.     set geom [blt_table info $win]
  354.     if {$position != ""} {
  355.         set geom [lreplace $geom 0 1 $position]
  356.     } else {
  357.         set geom [lrange $geom 1 end ]
  358.     }
  359.     eval "blt_table $master $path $geom"
  360.     if {$type == "frame"} {
  361.         bindtags $path "First frame widget [bindtags $path]"
  362.     } else {
  363.         bindtags $path "First widget [bindtags $path]"
  364.     }
  365.     set Widgets($name) 1
  366.     undo_log create_widget $name
  367.     widget_extract $path $name
  368.     outline_create $name
  369.  
  370.     catch {unset dst(focus)}
  371.     set dst(item_name) $name
  372.     set dst(pathname) $name
  373.  
  374.     # If this is a frame, copy all its children, 
  375.     # Then make the grid and arrows (broken, but close)
  376.  
  377.     if {[info exists Frames($win)]} {
  378.         dputs "COPYING SUB FRAME $win"
  379.         grid_size $win maxrows maxcols
  380.         frame_create $path $maxrows $maxcols
  381.         foreach child [blt_table slaves $win] {
  382.             dputs "Copying $child for $win"
  383.             if {[info exists Widgets([winfo name $child])]} {
  384.                 set new [copy_widget $path $child]
  385.                 set_master  $new $path
  386.                 after idle "outline_trace [winfo name $new]"
  387.             }
  388.         }
  389.         arrow_update .can $path
  390.     }
  391.     return $path
  392.  
  393.     # need to do sub-frame processing here (Broken!)
  394.  
  395.     if {[info exists dst(panel)]} {
  396.         read_file $dst(panel) $path
  397.     }
  398. }
  399.  
  400. # move a widget to row,col and update form entries 
  401. #  table:  Where to move the table to
  402. #  win:    The name of the window to move
  403. #  row,column:  Where in the table to put it
  404.  
  405. proc move_widget {table win row column} {
  406.     global Current
  407.     set Current(dirty) 1
  408.     set info [blt_table info $win]
  409.     blt_table forget $win
  410.     eval "blt_table $table [lreplace $info 1 1 $row,$column]"
  411.  
  412.     # this still isn't quite right
  413.     if {[winfo class $win] != "Frame"} {
  414.         raise $win
  415.     }
  416. }
  417.  
  418. # make the proper widget selected
  419. # 1 if frame and selected, de-select and select row/col instead
  420. # 2 if "parent" is current frame, select widget
  421. # 3 select parent who is a child of the current frame
  422.  
  423. set Current(widget) ""    ;# name of "current widget(s)?"
  424. set Current(text) ""        ;# the text or label of the current widget
  425. set Current(form) ""        ;# the widget with an active option sheet
  426. proc widget_up {win x y {focus ""}} {
  427.     global _Message Current 
  428.     set array_name [winfo name $win]
  429.     upvar #0 $array_name data
  430.     if {$focus != ""} {set data(focus) $focus}
  431.     
  432.     # Clicked in frame, select row/col
  433.  
  434.     if {$win == $Current(widget) && [regexp {^.can.f.frame#} $win]} {
  435.         dputs "selecting row/col in frame ($x,$y)"
  436.         current_frame $win
  437.         select_rowcol [expr $x - [winfo rootx $win]] [expr $y - [winfo rooty $win]]
  438.         return
  439.     }
  440.     
  441.     if {$win != $Current(widget)} {
  442.         unselect_widget
  443.         select_widget $win
  444.     }
  445. }
  446.  
  447. # make the named widget "selected"
  448. # as a side effect, make its "master" current
  449.  
  450. proc select_widget {win} {
  451.     global Current P
  452.     window_highlight $win
  453.     set name [winfo name $win]
  454.  
  455.     set master .can.f[find_master $win]
  456.     dputs $win in $master (current is $Current(frame))
  457.     table_setup $master        ;# testing
  458.     set Current(widget) $win
  459.     current_frame $master
  460.     if {![winfo exists ${win}_outline]} {    ;# we need to undo this!
  461.         outline_activate $name
  462.         outline_update $master
  463.     }
  464.     add_resize_handles $master.${name}_outline 3 1
  465.  
  466.     focus .entry
  467.     sync_all {}
  468.     arrow_unhighlight row
  469.     arrow_unhighlight column
  470. }
  471.  
  472. # If we selected a spot that is "out of bounds", then extend the table, 
  473. # and make sure the spot IS in bounds
  474.  
  475. proc check_table {table where myrow mycol} {
  476.     upvar $myrow row $mycol col
  477.     set add 0
  478.  
  479.     # check front of table
  480.     dputs $table at $where $row,$col
  481.  
  482.     if {$row <= 1} {
  483.         table_insert $table row [set row 2]
  484.         grid_process $table row 1
  485.         incr add
  486.     }
  487.     if {$col <= 1} {
  488.         table_insert $table column [set col 2]
  489.         grid_process $table column 1
  490.         incr add
  491.     }
  492.  
  493.     # check on grid lines
  494.  
  495.     if {$row&1} {
  496.         table_insert $table row [incr row]
  497.         grid_process $table row 1
  498.         incr add
  499.     }
  500.     if {$col&1} {
  501.         table_insert $table column [incr col]
  502.         grid_process $table column 1
  503.         incr add
  504.     }
  505.  
  506.     # check ends of table
  507.  
  508.     if {[string match *e $where]} {
  509.         resize_insert $table column 999
  510.         grid_process $table column 1
  511.         incr add
  512.     }
  513.     if {[string match s* $where]} {
  514.         resize_insert $table row 999
  515.         grid_process $table row 1
  516.         incr add
  517.     }
  518.     return $add
  519. }
  520.  
  521. # map grid locations into cursor styles
  522.  
  523. array set Choose_cursor {
  524.     Cr sb_v_double_arrow        Cc sb_h_double_arrow         Crc cross
  525.     s  sb_down_arrow            n  sb_up_arrow
  526.     e  sb_right_arrow            w  sb_left_arrow
  527.     nw top_left_corner            ne top_right_corner
  528.     sw bottom_left_corner        se bottom_right_corner
  529.     inside  dot
  530.     occupied X_cursor
  531.     reset {}
  532. }
  533.     
  534. # choose a "look" for the window based upon where we are
  535. # This version picks a new cursor, but anything that works...
  536.  
  537. proc choose_look {win where} {
  538.     global Choose_cursor
  539.     dputs $win $where
  540.     if {[info exists Choose_cursor($where)]} {
  541.         set cursor $Choose_cursor($where)
  542.     } else {
  543.         set cursor $Choose_cursor(inside)
  544.     }
  545.     $win configure -cursor $cursor
  546. }
  547.